home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
SPACE 1
/
SPACE - Library 1 - Volume 1.iso
/
program
/
16
/
block.fth
< prev
next >
Wrap
Text File
|
1985-11-19
|
3KB
|
104 lines
\ This file implements standard Forth BLOCKs
decimal
\ Some f83 words I don't otherwise have
: d= ( n1a n1b n2a n2b -- f ) rot = -rot = and ;
\ Interfaces to the system-dependent code that does the actual I/O
defer read-block (s buffer-header -- )
defer write-block (s buffer-header -- )
1024 constant b/buf
\ The order of >block# and >file# must be preserved, and they
\ must be at the start of the structure. The program accesses
\ them both at once with <header-address> 2@
: struct 0 ;
: field \ name ( offset size -- offset' )
create over , +
does> @ +
;
struct ( buffer )
/n field >block#
/n field >file#
/n field >bufadd
/n field >bufflags
constant /bufhdr
: /bufhdr* /bufhdr * ;
\ Allocation of data structures
4 constant #buffers
create >buffers #buffers 1+ /bufhdr* allot
create first b/buf #buffers * allot
here constant limit
: buffer# (s n -- adr ) /bufhdr* >buffers + ;
: >update (s -- adr ) 1 buffer# >bufflags ;
: update (s -- ) >update on ;
: discard (s -- ) 1 >update ! ;
: ?write-block ( buf-header -- buf-header )
dup >bufflags @ 0<
if dup >bufadd @ over 2@ write-block dup >bufflags off then
;
: missing (s -- )
#buffers buffer# ?write-block ( buffer-header )
>bufadd @ >buffers >bufadd ! ( buffer ) 1 >buffers >bufflags !
>buffers dup /bufhdr + #buffers /bufhdr* cmove> ;
: latest? (s n fcb -- fcb n | a f )
swap ( offset @ + ) 2dup 1 buffer# 2@ d=
if 2drop 1 buffer# >bufadd @ false r> drop then ;
: absent? (s n fcb -- a f )
latest? false #buffers 1+ 2
do drop 2dup i buffer# 2@ d=
if 2drop i leave else false then
loop ?dup
if buffer# dup >buffers /bufhdr cmove >r >buffers dup /bufhdr +
over r> swap - cmove> 1 buffer# >bufadd @ false
else >buffers 2! true then ;
: (buffer) (s n fcb -- a ) pause absent?
if missing 1 buffer# >bufadd @ then ;
: (block) (s n fcb -- a )
(buffer) >update @ 0>
if 1 buffer# dup >bufflags on \ set flags to "block invalid"
dup >bufadd @ over 2@ read-block
>bufflags off \ set flags to "block clean"
then ;
: empty-buffers (s -- )
first limit over - erase
>buffers #buffers 1+ /bufhdr* erase
first 1 buffer# #buffers 0
do dup on >bufadd 2dup ! swap b/buf + swap >bufadd
loop 2drop ;
: save-buffers (s -- )
1 buffer# #buffers 0
do dup @ 1+ if ?write-block then
/bufhdr +
loop drop ;
\ Some debugging tools
\ : .bh ( buffer-header -- )
\ dup >block# ." Block# " @ .
\ dup >file# ." File# " @ .
\ dup >bufadd ." Address " @ .
\ >bufflags ." Flags " @ .
\ ;
\ : .bhs (s -- ) #buffers 1+ 0 do i buffer# .bh cr loop ;
\
\ : .read ( bufadd file block -- ) ." Read " . . . cr ;
\ : .write ( bufadd file block -- ) ." Write " . . . cr ;
\ ' .read is read-block
\ ' .write is write-block
empty-buffers
needs file-io blockio.fth
file-io
needs load blockld.fth